home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / chgsysd.com / CHGSYSDT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-01-14  |  11.5 KB  |  351 lines
  1.  (************************************************************************
  2.      Program:     CHGSYSDT.TPU
  3.  
  4.      Description: Full Month Calendar Unit for Turbo Pascal 5.0
  5.  
  6.      Author:      Dennis Passmore
  7.                   1421 PineTree Drive
  8.                   Edgewater, Fl. 32032
  9.                   (904) 427-8537 CIS 72746,2674
  10.  
  11.      Created:     1/14/1989
  12.  
  13.      Copyright (c) 1989 Dennis Passmore, all rights reserved.
  14.  
  15.                         NO NONSENSE PROGRAM LICENSE
  16.  
  17.      Dennis  Passmore  reserves  the  COPYRIGHT  to  this  program and all
  18.      related materials. The user is granted a non-exclusive license to use
  19.      the program and  is encouraged to pay for the  program if it is found
  20.      to be  useful. Payment of  the $5 registration  fee will entitle  the
  21.      user  to  full  registration  which  includes  permission to use this
  22.      program  in  the  user's  OWN  PERSONAL  PROGRAMS. Programs which use
  23.      CHGSYSDT.TPU and that are offered to the public either as commercial,
  24.      shareware, or freeware  must pay a site license fee  of $25 to Dennis
  25.      Passmore for use of CHGSYSDT.TPU.
  26.  
  27.      CONTACT DENNIS PASSMORE IF YOU PLAN TO USE ANY PART OF THIS UNIT.
  28.  
  29.      Dennis Passmore  specifically disclaims all  warranties, expressed or
  30.      implied,  including  but  not   limited  to,  implied  warranties  of
  31.      merchantability and  fitness for any particular  purpose. In no event
  32.      shall Dennis Passmore  be liable for any loss of  profit or any other
  33.      commercial damage, including but  not limited to special, incidental,
  34.      consequential or other damages.
  35.  
  36.  
  37.                                 PROGRAM USE
  38.  
  39.      CHGSYSDT.TPU is a Turbo Pascal 5.0 unit designed to allow programmers
  40.      to add full month calendar routines into their programs. The routines
  41.      in CHGSYSDT.TPU will operate monochrome  or color systems. The entire
  42.      unit is self-contained and does not require error checking. Functions
  43.      available through CHGSYSDT.TPU include:
  44.  
  45.       MoveToScreen       ( moves contents of user buffer to screen )
  46.  
  47.       MoveFromScreen     ( moves contents of screen to user buffer )
  48.  
  49.       Save_Screen        ( allocates buffer space and saves screen data )
  50.  
  51.       Restore_Screen     ( restores screen data and frees buffer space )
  52.  
  53.       Draw_Calendar      ( draws full month calendar on screen )
  54.  
  55.       Select_New_Date    ( draws calendar on screen and allows user to
  56.                            cursor select the month or date desired. )
  57.  
  58.  
  59.                            Sample Screen Output
  60.                       ╔═══════════════════════════╗
  61.                       ║     January 14, 1989      ║
  62.                       ╟───┬───┬───┬───┬───┬───┬───╢
  63.                       ║Sun│Mon│Tue│Wed│Thr│Fri│Sat║
  64.                       ╟───┼───┼───┼───┼───┼───┼───╢
  65.                       ║  1│  2│  3│  4│  5│  6│  7║
  66.                       ╟───┼───┼───┼───┼───┼───┼───╢
  67.                       ║  8│  9│ 10│ 11│ 12│ 13│ 14║
  68.                       ╟───┼───┼───┼───┼───┼───┼───╢
  69.                       ║ 15│ 16│ 17│ 18│ 19│ 20│ 21║
  70.                       ╟───┼───┼───┼───┼───┼───┼───╢
  71.                       ║ 22│ 23│ 24│ 25│ 26│ 27│ 28║
  72.                       ╟───┼───┼───┼───┼───┼───┼───╢
  73.                       ║ 29│ 30│ 31│   │   │   │   ║
  74.                       ╟───┼───┼───┼───┼───┼───┼───╢
  75.                       ║   │   │   │   │   │   │   ║
  76.                       ╚═══╧═══╧═══╧═══╧═══╧═══╧═══╝
  77.  
  78.  ************************************************************************)
  79.  
  80. unit ChgSysDt;
  81.  
  82. interface
  83.  
  84. uses
  85.   Crt,
  86.   Dos,
  87.   StrOf,    { from Turbo 4.0 manual page 355 or Turbo 5.0 manual page 213 }
  88.  
  89.             { The next 2 units are from the BORLAND TP4 SIG and were }
  90.   Dates,    { created by   Scott Bussinger                }
  91.   Cursors;               { Professional Practice Systems
  92.                            110 South 131st Street
  93.                            Tacoma, WA  98444
  94.                            (206)531-8944
  95.                            Compuserve 72247,2671          }
  96.  
  97.  
  98. Procedure MoveToScreen(Var Source,Dest; Length: Integer);
  99.  
  100. Procedure MoveFromScreen(Var Source,Dest; Length: Integer);
  101.  
  102. procedure Save_Screen;
  103.  
  104. procedure Restore_Screen;
  105.  
  106. procedure Draw_Calendar(y,m,d: integer;x,z:integer);
  107.  { parameters required are - Year , Month, Day and screen locations X, Z }
  108.  
  109. procedure Select_New_Date;
  110.  
  111. implementation
  112.  
  113. const
  114.   CGA   = $B800;
  115.   Mono  = $B000;
  116.  
  117. type
  118.   vidbfr = array[1..4000] of byte;
  119. var
  120.   mnth,day,
  121.   year,wday: word;
  122.   inkey    : char;
  123.   Jdate    : date;
  124.   saved    : boolean;
  125.   scrnloc  : word;
  126.   scrptr   : pointer;
  127.   scrbfr   : ^vidbfr;
  128.  
  129.  
  130. procedure Initialize_Screen_Vars;
  131.   begin
  132.     if lastmode=7 then
  133.       scrnloc := Mono
  134.     else
  135.       scrnloc := CGA;
  136.     scrptr := ptr(scrnloc,0);
  137.     saved  := false;
  138.     scrbfr := nil;
  139.   end;
  140.  
  141. { The next 2 procedures - MoveToScreen & MoveFromScreen are borrowed from }
  142. { someone else's code from a file on BORLAND TP3 SIG but I don't know who. }
  143.  
  144. Procedure MoveToScreen(Var Source,Dest; Length: Integer);
  145.   Begin
  146.     If scrnloc=Mono Then
  147.       Move(Source,Dest,Length)
  148.     Else
  149.       Begin
  150.         Length:=Length Shr 1;     { wait for retrace routine }
  151.         Inline($1E/$55/$BA/$DA/$03/$C5/$B6/ Source /$C4/$BE/ Dest /$8B/$8E/
  152.              Length /$FC/$AD/$89/$C5/$B4/$09/$EC/$D0/$D8/$72/$FB/$FA/$EC/
  153.              $20/$E0/$74/$FB/$89/$E8/$AB/$FB/$E2/$EA/$5D/$1F);
  154.       End;
  155.   End;
  156.  
  157. Procedure MoveFromScreen(Var Source,Dest; Length: Integer);
  158.   Begin
  159.     If scrnloc=Mono Then
  160.       Move(Source,Dest,Length)
  161.     Else
  162.       Begin
  163.         Length:=Length Shr 1;     { wait for retrace routine }
  164.         Inline($1E/$55/$BA/$DA/$03/$C5/$B6/ Source /$C4/$BE/ Dest /$8B/$8E/
  165.              Length /$FC/$EC/$D0/$D8/$72/$FB/$FA/$EC/$D0/$D8/$73/$FB/$AD/
  166.              $FB/$AB/$E2/$F0/$5D/$1F);
  167.       End;
  168.   End;
  169.  
  170.  
  171. procedure Save_Screen;
  172.   begin
  173.     if (not saved)and(memavail>4000) then
  174.       begin
  175.         saved := true;
  176.         new(scrbfr);
  177.         MoveFromScreen(scrptr^,scrbfr^,4000);
  178.       end
  179.     else
  180.       write(^G);
  181.   End;
  182.  
  183. procedure Restore_Screen;
  184.   begin
  185.     if Saved then
  186.       begin
  187.         MoveToScreen(scrbfr^,scrptr^,4000);
  188.         dispose(scrbfr);
  189.         saved := false;
  190.       end
  191.     else
  192.       write(^G);
  193.   end;
  194.  
  195. procedure Draw_Calendar(y,m,d: integer;x,z:integer);
  196.  { parameters required are - Year , Month, Day and screen locations X, Z }
  197.   const top_row  = '╔═══════════════════════════╗';
  198.         divider0 = '╟───┬───┬───┬───┬───┬───┬───╢';
  199.         divider1 = '║Sun│Mon│Tue│Wed│Thr│Fri│Sat║';
  200.         divider2 = '╟───┼───┼───┼───┼───┼───┼───╢';
  201.         divider3 = '║   │   │   │   │   │   │   ║';
  202.         bottom   = '╚═══╧═══╧═══╧═══╧═══╧═══╧═══╝';
  203.   var ix1,ix2,im,iy,wx,wy,
  204.       sr,sc,nm,cday : integer;
  205.       sMonth        : String[36];
  206.       sMl           : byte absolute sMonth;
  207.       tmp1,tmp2     : string[4];
  208.       WinMin,WinMax,
  209.       invatr,nrmatr : word;
  210.   begin
  211.     if (x<1) or (x>52) or ((x=52)and(z>8)) or (z<1) or (z>9) then
  212.       write(^G)
  213.     else
  214.       begin
  215.    { make sure we have a full size window before writing to the screen }
  216.         WinMin := WindMin; WinMax := WindMax;
  217.         wx := wherex;  wy := wherey; window(1,1,80,25);
  218.         str(d,tmp1); str(y,tmp2); ix2 := 0;
  219.         sMonth := ' '+MonthString(m)+' '+tmp1+', '+tmp2+' ';
  220.         if odd(sMl) then ix1:=14 else ix1:=13;
  221.         gotoxy(x,z+ix2); write(top_row); inc(ix2);
  222.         gotoxy(x,z+ix2); write('║'+stringof(' ',ix1-((sMl+1) div 2))+sMonth
  223.                              +stringof(' ',14-((sMl+1) div 2))+'║'); inc(ix2);
  224.         gotoxy(x,z+ix2); write(divider0); inc(ix2);
  225.         gotoxy(x,z+ix2); write(divider1); inc(ix2);
  226.         for ix1 := 1 to 6 do
  227.           begin
  228.             gotoxy(x,z+ix2); write(divider2); inc(ix2);
  229.             gotoxy(x,z+ix2); write(divider3); inc(ix2);
  230.           end;
  231.         gotoxy(x,z+ix2); write(bottom);
  232.         iy := y; im := m;
  233.         nm := im+1;
  234.         if nm = 13 then nm := 1;
  235.         DMYtoDate(1,im,iy,Jdate);
  236.         ix1 := (Succ(Jdate) mod 7);
  237.         sr := z+5; sc := x+1+(ix1*4);
  238.         nrmatr := textattr;
  239.         invatr := (textattr mod 16) shl 4+(textattr div 16);
  240.         DatetoDMY(Jdate,cday,im,iy);
  241.         repeat
  242.           gotoxy(sc,sr);
  243.           if d=cday then
  244.             textattr := invatr;
  245.           write(' ',cday:2);
  246.           textattr := nrmatr;
  247.           if (((cday+ix1)mod 7)=0) then
  248.             begin
  249.               inc(sr,2);
  250.               sc := x+1;
  251.             end
  252.           else
  253.             inc(sc,4);
  254.           inc(jdate);
  255.           DatetoDMY(Jdate,cday,im,iy);
  256.         until (im=nm);
  257.         inc(sr);
  258.         if sr=z+14 then
  259.           begin
  260.             gotoxy(x,sr); write(divider2); inc(sr);
  261.             gotoxy(x,sr); write(divider3); inc(sr);
  262.           end;
  263.         gotoxy(x,sr);
  264.         write(bottom);
  265.               { now we put it back to the way we found it }
  266.         window(Lo(WinMin)+1,Hi(WinMin)+1,Lo(WinMax)+1,Hi(WinMax)+1);
  267.         gotoxy(wx,wy);
  268.       end;
  269.   end;
  270.  
  271. procedure Select_New_Date;
  272.   const
  273.     up1 = 1; dn1 = -1; zero = 0;
  274.   var
  275.     Jdate1, Jdate2      : date;
  276.     year,mnth,day,wday  : word;
  277.     x,y,iyer,imth,iday  : integer;
  278.   begin
  279.     GetDate(year,mnth,day,wday);
  280.     iyer := year;
  281.     imth := mnth;
  282.     iday := day;
  283.     DMYtoDate(iday,imth,iyer,Jdate1);
  284.     Jdate2 := Jdate1;
  285.     inkey := #0;
  286.     x  := 22;
  287.     y  :=  5;
  288.     Save_Screen;
  289.     Makecursor(Nocursor);
  290.     gotoxy(x+2,y+17); write(#27+#24+#25+#26+' Change  «╝ To SetDate');
  291.     gotoxy(x+10,y+18);                   write('ESC Exit');
  292.     while not (inkey in [#13,#27]) do
  293.       begin
  294.         Draw_Calendar(iyer,imth,iday,x,y);
  295.         repeat
  296.           inkey := readkey;
  297.         until inkey in [#0,#13,#27];
  298.         if inkey = #0 then
  299.           begin
  300.             inkey := readkey;
  301.             case inkey of
  302.               #71: begin  { Home - current date }
  303.                      Jdate2 := Jdate1;
  304.                      iyer := year;
  305.                      imth := mnth;
  306.                      iday := day;
  307.                    end;
  308.               #72,#73,
  309.               #75,#77,
  310.               #80,#81: begin
  311.                          case inkey of
  312.    { Up Ar - up a month }  #72: Jdate2 := BumpDate(Jdate2,zero,up1,zero);
  313.    { Pg Up - up a year }   #73: Jdate2 := BumpDate(Jdate2,zero,zero,up1);
  314.    { Left  - down a day}   #75: if Jdate2>0 then
  315.                                     Jdate2 := BumpDate(Jdate2,dn1,zero,zero)
  316.                                   else
  317.    { Dn Ar - down a month }         Jdate2 := BumpDate(Jdate2,zero,dn1,zero);
  318.    { Right - up a day }    #77: if Jdate2<65520 then
  319.                                   Jdate2 := BumpDate(Jdate2,up1,zero,zero)
  320.                                 else
  321.    { Up Ar - up a month }         Jdate2 := BumpDate(Jdate2,zero,up1,zero);
  322.    { Dn Ar - down a month }#80: Jdate2 := BumpDate(Jdate2,zero,dn1,zero);
  323.    { Pg Dn - down a year } #81: Jdate2 := BumpDate(Jdate2,zero,zero,dn1);
  324.                          end;
  325.                          DatetoDMY(Jdate2,iday,imth,iyer);
  326.                        end;
  327.               else
  328.                 write(^G);
  329.             end;
  330.           end
  331.         else
  332.           if (inkey=#13)and(iyer<1980) then
  333.             begin
  334.               inkey := #0;
  335.               write(^G);
  336.             end;
  337.       end;
  338.     Restore_Screen;
  339.     MakeCursor(RestoreCursor);
  340.     year := iyer;
  341.     mnth:= imth;
  342.     day := iday;
  343.     if inkey=#13 then
  344.       SetDate(year,mnth,day);
  345.   end;
  346.  
  347. begin
  348.   Initialize_Screen_Vars;
  349. end.
  350.  
  351.